\ MVP-FORTH - CROSS-COMPILE LOAD SCREEN gst851223" mvp.amg" initiate \ object to go here !! \ drives quit quit quit HEX 1F W-FORTH ! ( SET NAME FIELD WIDTH OF 79-STANDARD WORDS ) 1F W-MVP ! ( SET NAME FIELD WIDTH OF MVP-FORTH WORDS ) CROSS-COMPILE swap-bytes align \ -4 d000 ORG/IMG \ SET HOST ORIGIN -4 so next=0(bp) -4 0 on3 dup . org/db \ disk on next drive fff0 EQU EM ( SET HOST END OF MEMORY ) DECIMAL 4 128 HEX THRU IS-FENCE FINIS decimal EXIT ( MVP-FORTH - CROSS-COMPILE LOAD SCREEN MVP-FORTH) HEX 1F W-FORTH ! ( SET NAME FIELD WIDTH OF 79-STANDARD WORDS ) 1F W-MVP ! ( SET NAME FIELD WIDTH OF MVP-FORTH WORDS ) CROSS-COMPILE 100 A100 ORG/IMG ( SET HOST ORIGIN ) 6000 EQU EM ( SET HOST END OF MEMORY ) DECIMAL 101 204 HEX THRU IS-FENCE FINIS EXIT ( FORTH-79 STANDARD - CROSS-COMPILE LOAD SCREEN MVP-FORTH) HEX 1F W-FORTH ! ( SET NAME FIELD WIDTH OF 79-STANDARD WORDS ) 0 W-MVP ! ( SET NAME FIELD WIDTH OF MVP-FORTH WORDS ) CROSS-COMPILE 100 A100 ORG/IMG ( SET HOST ORIGIN ) 6000 EQU EM ( SET HOST END OF MEMORY ) DECIMAL 101 204 HEX THRU IS-FENCE FINIS EXIT ( EQUATES FOR ASCII CHARACTERS MVP-FORTH) ( THE FOLLOWING EQUATES NAME ASCII CHARACTERS ) 20 EQU ABL ( AN ASCII BLANK ) 0D EQU ACR ( AN ASCII CARRIAGE RETURN ) 2D EQU AMINUS ( AN ASCII MINUS ) 2E EQU ADOT ( AN ASCII . ) 07 EQU BELL ( AN ASCII CONTROL G ) 0A EQU ALF ( AN ASCII LINE FEED ) 0C EQU FFEED ( AN ASCII FORM FEED ) 7F EQU ADEL ( AN ASCII DELETE ) 10 EQU ADLE ( AN ASCII ^P ) 08 EQU BSOUT ( AN ASCII BACKSPACE SENT TO KEYBOARD ) 08 EQU BSIN ( AN ASCII BACKSPACE SENT FROM KEYBOARD ) ( COMBUTE THE FIRST DISK BUFFERS ADDRESS MVP-FORTH) ( SPECIFY THE SIZE OF DISK BUFFER HEAD, BUFFER AND TAIL ) 404 EQU HDBT ( SPECIFY THE NUMBER OF BUFFERS REQUIRED. ) 2 EQU NBUF ( COMPUTE THE ABSOLUTE ADDRESS OF THE FIRST DISK BUFFER. ) EM HDBT NBUF * - EQU BUF1 \ COMPUTE THE INITIAL STACK ADDRSSES gst850927 ( SET THE SIZE OF THE USER AREA. ) 52 EQU US ( COMPUTE THE ABSOLUTE ADDRESS OF THE INITIAL RETURN STACK. ) BUF1 US - EQU INIT-R0 ( SET THE SIZE OF THE RETURN STACK AND TERMINAL INPUT BUFFER. ) 60 EQU RTS \ no rp, but used as TIB (normally A0) ( COMPUTE THE ABSOLUTE ADDRESS OF THE INITIAL PARAMETER STACK. ) INIT-R0 RTS - EQU INIT-SP0 \ MOUNTIAN VIEW PRESS FORTH ENTRY POINT gst851106 ASSEMBLER \ entry here then BRA beyond user area init 3000 BRA here 2- \ 16 bit displacement \ This BRA's *VERY* far !!!!!!! Must be 4 bytes !!!! \ NEXT *MUST* be here, this is where the Base Pointer \ points so next can jmp via BP with no displacement HERE LABEL >NEXT< \ special label for single next ip )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp FORTH here label IncomingSP 0 , 0 , \ daddr of incoming SP \ USER AREA INITIALIZATION 1 OF 2 gst850914 HERE LABEL INIT-FORTH 0 , ( INITIAL POINTER TO THE TOP ENTRY IN FORTH VOC ) HERE LABEL INIT-USER INIT-SP0 , ( PARAMETER STACK ADDRESS SP0 ) INIT-R0 , ( RETURN STACK ADDRESS R0 ) \ not used !! INIT-SP0 , ( TERMINAL INPUT BUFFER ADDRESS ) 01F , ( NAME FIELD WIDTH IN BYTES ) 1 , ( ERROR WARNING MODE ) HERE LABEL INIT-FENCE 0 , ( FENCE ADDRESS FOR FORGETTING DICTIONARY ENTRIES ) HERE LABEL INIT-DP 0 , ( INITIAL DICTIONARY POINTER ) HERE LABEL INIT-VOC-LINK 0 , ( INITIAL VOCABULARY LINK ) \ USER AREA INITIALIZATION 2 OF 2 gst851106] <-FIND> <?TERMINAL> <ABORT> <BLOCK> <CR> <EMIT> <EXPECT> <INTERPRET> <KEY> <LOAD> <NUMBER> <PAGE> <R/W> <TYPE> ( was T&S Calc --- Not used ) <VOCABULARY79> <WORD> [ \ USER AND RETURN STACK POINTERS gst851106 ( USER POINTER. ) HERE LABEL UP INIT-R0 , ( RETURN STACK POINTER. ) HERE LABEL RPP \ here, but not used !!!! INIT-R0 , \ ExecBase GfxBase DosBase MyRaster Registers gst851223 \ These are names to use for common library base values. create ExecBase 0 , 0 , \ EXEC library pointer (from 4) create GfxBase 0 , 0 , \ graphics.library base create DosBase 0 , 0 , \ dos.library base create IntuBase 0 , 0 , \ intuition.library base create REGISTERS 40 allot \ 16 regs x 4 bytes create Arguments \ incoming arguments when pgm invoked 0 , 0 , \ pointer ( incoming A0 ) 0 , \ length ( incoming D0 ) create WBmsg 0 , 0 , \ if under WB, msg to reply on BYE create ThisTask 0 , 0 , \ will be addr to this task \ MOUNTIAN VIEW PRESS FORTH ENTRY POINT gst851223ASSEMBLER \ entry BRA's to here here label 'cold ] COLD [ \ first thing to next to FORTH \ This pairs with a BRA a few screens back !!!! here over - swap ! \ 16 bit displaced BRA ASSEMBLER \ save incoming regs, then set up forth regs 48E7 , 7FFE , \ MOVEM D1-D7/A0-A6,-(RP) save all regs w long clr os long clr word \ init work regs here 2+ negate pcd) bp lea \ setup base pointer a0 arguments bp d) lmove d0 arguments 4 + bp d) move 'cold bp d) ip lea \ init ip too Init-User bp d) w move 0 w bp di.l) sp lea rp IncomingSP bp d) long move word \ save original REAL sp next FORTH \ BANNER gst851114 : Banner \ -- | just some information ." MVP-FORTH is not optimized and is intended to introduce" cr ." you to FORTH. Mountain View Press is your FORTH SOURCE." cr ." Please call (415)961-4103 in the USA to order books," cr ." extensions and enhancements for use with MVP-FORTH." cr ." If you didn't buy this program from Mountain View Press" cr ." and find it of value, your financial contribution" cr ." to the author at the address below would be appreciated:" cr ." Fantasia Systems Inc." cr ." P. O. Box 5260" cr ." San Mateo, CA 94402" cr ; \ LIT! LIT2! LITW! LITX! gst851001 code LIT! ( value -- [addr] \ store value at addr ) IP )+ os move SP )+ 0 os bp di.l) move next end-code code LIT2! ( dvalue -- [addr] \ store double num at addr ) ip )+ os move sp )+ 0 os bp di.l) long move word next end-code code LITW! ( value -- [addr] \ 2!, padding with 0 ) ip )+ os move sp )+ W move W 0 os bp di.l) long move word next end-code code LITX! ( value -- [addr] \ do a 'sign extending' 2! ) ip )+ os move sp )+ A0 move A0 0 os bp di.l) long move word next end-code \ resident library interfacing gst851106assembler here label LIBRTS \ the RTS from library: lands here!! 4CDF , 7CF0 , \ MOVEM (RP)+,D4-D7/A2-A6 4 IP long addq word NEXT \ LIBRARY: is done, we can go on code LIBRARY: ( -- [libbase] [lvo] d0 \ call a library) 48E7 , 0F3E , \ MOVEM D4-D7/A2-A6,-(RP) IP )+ OS move 0 OS BP di.l) A0 long move word IP )+ D0 move D0 long ext A0 A6 long move word LIBRTS BP d) pea 0 D0 A6 di.l) pea 4CEB , 3FFF , registers , \ MOVEM registers(BP),D0-D7/A0-A5 RTS end-code \ return to the pushed address in the lib \ NOTE: we assume that D0 is preserved thru NEXT, so that \ the LIBRARY: can be followed immediately by RESULT \ Result >daddr 2@L 2!L gst851001 code Result ( -- dresult \ push D0 after a LIBRARY: ) D0 SP -) long MOVE word next end-code code A>L \ addr -- longaddr | convert to absolute addr sp )+ os move 0 os bp di.l) a1 lea a1 sp -) long move word next end-code code 2@L \ daddr - d | long double fetch long sp )+ a0 move a0 ) sp -) move word next end-code code 2!L \ d daddr -- | long double store long sp )+ a0 move sp )+ a0 ) move word next end-code \ !L @L C!L C@L gst851001 MVP CODE !L sp )+ a0 lmove sp )+ a0 ) move next end-code MVP CODE @L sp )+ a0 lmove a0 ) sp -) move next end-code MVP CODE C!L sp )+ a0 long move word sp )+ d0 move d0 a0 ) byte move word next end-code MVP CODE C@L sp )+ a0 long move d0 clr a0 ) d0 byte move word d0 sp -) move next end-code \ <bye> ((")) gst851223 code <bye> \ actually used to return to caller IncomingSP bp d) rp long move word \ get original REAL sp 4CDF , 7FFE , \ MOVEM (RP)+,D1-D7/A0-A6 restore regs d0 long clr word rts end-code code ((")) \ used in a : definition ONLY!!! rp ) os move d0 long clr word \ os=addr of string 0 os bp di.l) d0 byte move word \ d0=count (w/out null) d0 d1 long move os d1 add word \ d1=next rp value 3 d1 addq ( for null + length byte + 1 to and ) fffe # d1 and d1 rp ) move \ update and aligned 1 os addq os sp -) move ( addr ) d0 sp -) move ( count ) next end-code \ +Null (") " gst851106 : +Null \ addr # -- addr # | place a null at end of string 2dup + 0 swap c! ; \ force a null at end of " : (") ((")) ; \ -- addr count | using our primitive : (,") \ -- | ..." || # & string w/null & aligned at end! 22 word count +null 2+ allot aligned drop ; : " \ -- addr count || ..." | string state smart uses PAD state @ IF compile (") (,") \ get strng ELSE 22 word count +null \ string not compiled >R pad r@ 1+ cmove pad r> \ at PAD THEN ; immediate \ if not compiled, string at PAD !!!!! \ constants strings for amiga use gst851223create StdIn 0 , 0 , create StdOut 0 , 0 , create AltOut 0 , 0 , \ you make it whatever you want : "Dos" " dos.library" ; \ so you can easily change it : "Gfx" " graphics.library" ; : "Raw" " RAW:0/0/640/200/MVP-FORTH Fantasia Systems Inc. Glenn Tenney 851223" ; \ Amiga's names are too long !!!! decimal 1005 constant Old 1006 constant New hex -1 constant Offset_Beginning 0 constant Offset_Current 1 constant Offset_End \ OpenLibrary Open Close Read Write gst851106 : OpenLibrary \ addr # version -- dbase | open that library >rd 0W +null drop A>L >ra 1 exec: FE68 result ; : Open \ addr # mode -- dfile | opens file >rd 2X +null drop A>L >rd 1 dos: FFE2 result ; : Close >rd 1 dos: FFDC ; \ dfile -- | close it : Read \ dbuf len dfile -- real-len | read len bytes >rd 1 >rd 3W >rd 2 dos: FFD6 result drop ; : Write \ dbuf len dfile -- real-len | write len bytes >rd 1 >rd 3W >rd 2 dos: FFD0 result drop ; \ IOErr Seek gst851106 : IOErr dos: FF7C result drop ; \ -- error# | : Seek \ doffset dfile mode -- dbyte# | >rd 3X >rd 1 >rd 2 DOS: FFBE result ; : Debug exec: FF8E ; \ enter RomWack \ <key> <?terminal> <emit> <type> gst851106: <key> 0 sp@ 1+ ( read char onto stack ) A>L 1 StdIn 2@ read drop ; : <?terminal> StdIn 2@ >rd 1 \ do WaitForChar 0 >RD 2W DOS: FF34 result drop ; : <type> \ addr count -- | send that string dup out +! ( update counter ) >R A>L 2dup r@ StdOut 2@ Write drop \ std output R> Eprint @ IF \ echo to another file? AltOut 2@ or \ see if any handle there IF AltOut 2@ Write drop EXIT THEN THEN 2drop drop ; \ done w/ daddr and length : <emit> sp@ 1+ 1 <type> drop ; \ c -- | \ (open) MaxFile FileWidth/Table Blocks/File gst851223 : (open) \ addr count mode -- dhandle | validated open dup new = over old = or 0= Abort" Invalid mode" >r 2dup + c@ Abort" Invalid filename" r> Open 2dup or 0= Abort" Open error" ; 8 constant MaxFile \ max number of files 2A ( 42 decimal ) constant FileWidth \ width of table create FileTable \ dhandle length filename FileWidth maxfile * allot \ room for fileinfo 3e8 ( 1000 ) constant Blocks/File \ max # blocks / file \ FileHandle/Name/Size Select File0 File1 gst851223: FileHandle \ n -- addr | pt to file dhandle file n maxfile 1- over u< abort" Invalid file number" FileWidth * filetable + ; : FileSize \ n -- addr | pt to size of file in blocks filehandle 4 + ; \ leaving a couple of words here for possible extensions : FileName \ n -- addr | pt to count byte of name FileSize 6 + ; : Select \ n -- | set offset for appropriate file n blocks/file * offset ! ; : File0 0 select ; : File1 1 select ; \ File# NextFile FileSize! gst851223 : File# \ -- n | what file number is current offset @ blocks/file / ; : NextFile \ -- n | next avail file (fm 0) or -1 if none -1 MaxFile 0 DO I FileHandle 2@ or 0= IF drop I leave THEN LOOP ; \ leave n : FileSize! \ n -- | set size of file # n in blocks dup FileHandle 2@ 2dup or IF \ if file there 0. 2over Offset_End Seek 2drop \ DOS is WRONG!!! 0. 2swap Offset_End Seek \ this is really answer 400 ( 1024 ) u/mod swap drop \ file# #blocks ELSE drop THEN \ file handle is 0 which is its size swap FileSize ! ; \ set size of file in blocks \ Files CloseFile (file) gst851223: Files \ -- | show all files MaxFile 0 DO cr File# i = if ." *" else space then ." File" i 3 .r space i filehandle 2@ or IF i filename count type \ file is open i filesize @ 5 .r ." blocks" THEN LOOP cr ; : CloseFile \ n -- | close file n save-buffers 0 over filename c! ( count=0 1st is ok ) filehandle dup 2@ 2dup or if close empty-buffers else 2drop then 0 0 rot 2! ; \ mark it closed : (file) \ -- addr # | get file name from input stream bl word count +null ; \ just get name \ SetFile FILE gst851223: SetFile \ addr count dhandle -- | set this as current file File# dup CloseFile ( make sure ) dup >r FileHandle 2! 30 min ( max length ) dup r@ FileName c! ( stuff count byte ) r@ FileName 1+ swap 1+ cmove ( get rest of name+null ) r> FileSize! ( finally set its size ) ; : FILE \ addr count mode -- | make this current file >r 2dup r> (open) SetFile ; \ make it current file : CloseAlt \ -- | close AltOut if open AltOut 2@ 2dup or if Close 0. AltOut 2! else 2drop then ; : Alternate \ addr count mode -- | open and set AltOut CloseAlt (open) AltOut 2! ; \ handle stored, \ CloseAll From Include gst851223\ These functions should be common with other implementations. : CloseAll \ -- | close all open blocks files MaxFile 0 DO i CloseFile LOOP ; : From \ -- | <name> blank delim'ed made current file (file) Old File ; \ must already exist : Include \ -- | <name> || 1 load from that file then close NextFile dup 0< Abort" No room for another file" >R (file) 2dup Old (open) ( open file ) r> File# >r Select ( new ) SetFile ( from new ) 1 load File# CloseFile r> Select ; \ back \ " foo" old file .or. " foo" new file \ from foo .or. include foo ( to 1 load then close ) \ Larger gst851223\ These functions should be common with other implementations. : Larger \ n -- | makes current file n blocks larger 1 ?enough \ must have one thing on stack Save-Buffers ( be sure ) File# ( use this file ) FileHandle 2@ 2dup or IF ( only if there is one ) 7FFF buffer 400 bl fill ( will be a work area ) 0. 2swap Offset_end seek 2drop ( pt at end ) 0 DO 7FFF block A>L ( use work area ) 400 File# filehandle 2@ write ( write 1k ) 400 - abort" Error enlarging file" LOOP File# FileSize! empty-buffers ELSE 2drop drop THEN ; \ otherwise nada \ used like: \ 5 larger \ to make current file 5 blocks larger \ ColdSwitch OpenLibraries OpenConsole gst851223 create ColdSwitch 0 , \ 0=do cold once only : OpenConsole \ -- | open stdin/out for console i/o "raw" Old open 2dup StdIn 2! StdOut 2! 0 0 AltOut ! ; \ and close out alt file : OpenLibraries \ -- | open desired libraries "dos" 0 openlibrary dosbase 2! ( dos library ) "gfx" 0 openlibrary gfxbase 2! ( gfx library ) ; : WB? \ -- f | t if running under WorkBench pr_CLI<>0 ThisTask 2@ 0AC ( pr_CLI ) 0 d+ 2@L or 0= ; \ AmigaCold gst851223 : AmigaCold \ -- | done only once until execbase set ColdSwitch @ 0= IF \ do this once only 1 ColdSwitch ! \ set to not do this again FileTable FileWidth MaxFile * 0 fill \ files all closed 4. 2@l execbase 2! \ set execbase OpenLibraries \ always need to do this 0 >ra 1W EXEC: FEDA ( 0 Findtask ) result ThisTask 2! \ set ptr to our own task WB? IF \ using pr_MsgPort equivalent of WaitMsg ThisTask 2@ 5C 0 d+ 2dup >ra 0 EXEC: FE80 >ra 0 EXEC: FE8C result WBmsg 2! \ ptr to msg THEN OpenConsole \ also always needed THEN ; \ ! # #> #BUFF gst851106 F-79 CODE ! \ sp must NOT be A7 !!!! sp )+ os move sp )+ 0 os bp di.l) byte move \ byte 1 sp )+ 1 os bp di.l) move word next end-code F-79 : # BASE @ M/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ; F-79 : #> 2DROP HLD @ PAD OVER - ; MVP NBUF CONSTANT #BUFF \ #S ' '-FIND '?TERMINAL 'ABORT gst850924F-79 : #S BEGIN # 2DUP OR NOT UNTIL ; F-79 : ' -FIND NOT ABORT" Not found" DROP [COMPILE] LITERAL ; IMMEDIATE MVP 16 USER '-FIND MVP 18 USER '?TERMINAL MVP 1A USER 'ABORT ( 'BLOCK 'CR 'EMIT 'EXPECT 'INTERPRET MVP-FORTH) MVP 1C USER 'BLOCK MVP 1E USER 'CR MVP 20 USER 'EMIT MVP 22 USER 'EXPECT MVP 24 USER 'INTERPRET ( 'KEY 'LOAD 'NUMBER 'PAGE 'R/W MVP-FORTH) MVP 26 USER 'KEY MVP 28 USER 'LOAD MVP 2A USER 'NUMBER MVP 2C USER 'PAGE MVP 2E USER 'R/W \ 'STREAM 'TYPE 'VOCABULARY 'WARM 'WORD gst851223MVP : 'STREAM BLK @ ?DUP IF BLOCK ELSE TIB @ THEN >IN @ + ; MVP 30 USER 'TYPE \ replaces slot used by T&Scalc MVP 32 USER 'VOCABULARY MVP create 'WARM ] <warm> [ \ to easily re-vector !! MVP 34 USER 'WORD ( ( * */ */MOD MVP-FORTH) F-79 : ( -1 >IN +! 29 WORD C@ 1+ HERE + C@ 29 = NOT ?STREAM ; IMMEDIATE F-79 : * U* DROP ; F-79 : */ */MOD SWAP DROP ; F-79 : */MOD >R M* R> M/ ; \ + +! +- +BUF gst851001F-79 CODE + sp )+ d0 move d0 sp ) add next end-code F-79 CODE +! sp )+ w move 0 w bp di.l) a1 lea \ real addr a1 )+ w byte move word 8 # w lsl a1 ) w byte move word sp )+ w add w a1 ) byte move word 8 # w lsr w a1 -) byte move word next end-code MVP : +- 0< IF NEGATE THEN ; MVP : +BUF HDBT + DUP LIMIT = IF DROP FIRST THEN DUP PREV @ - ; \ +LOOP , - -FIND gst850915 F-79 : +LOOP 3 ?PAIRS COMPILE <+LOOP> HERE - , ; IMMEDIATE F-79 : , HERE ! 2 ALLOT ; F-79 CODE - sp )+ d0 move d0 sp ) sub next end-code MVP : -FIND '-FIND @ EXECUTE ; \ -TRAILING . gst850924 F-79 : -TRAILING DUP 0 DO 2DUP + 1- C@ BL - IF LEAVE ELSE 1- THEN LOOP ; F-79 : . S->D D. ; \ ." gst851106 F-79 : ." 'STREAM C@ 22 = IF 1 >IN +! ELSE STATE @ IF COMPILE <."> (,") ELSE 22 WORD DUP C@ 1+ OVER + C@ 22 = NOT ?stream count type THEN THEN ; IMMEDIATE ( .LINE .R / /LOOP /MOD MVP-FORTH) MVP : .LINE <LINE> -TRAILING TYPE ; MVP : .R >R S->D R> D.R ; F-79 : / /MOD SWAP DROP ; MVP : /LOOP 3 ?PAIRS COMPILE </LOOP> HERE - , ; IMMEDIATE F-79 : /MOD >R S->D R> M/ ; \ 0 0< 0= 0> gst850920 MVP 0 CONSTANT 0 F-79 CODE 0< sp ) tst d0 smi 1 d0 andi d0 sp ) move next end-code F-79 : 0= NOT ; F-79 : 0> 0 > ; \ 0BRANCH 1 1+ 1- gst851001 MVP CODE 0BRANCH sp )+ d0 move 0<> if 2 ip long addq word \ bump over if <> else ip ) a0 move a0 ip long adda word then next end-code MVP 1 CONSTANT 1 F-79 CODE 1+ 1 sp ) addq next end-code F-79 CODE 1- 1 sp ) subq next end-code \ 2 2* 2+ 2- 2/ gst850927 MVP 2 CONSTANT 2 MVP CODE 2* sp ) asl next end-code F-79 CODE 2+ 2 sp ) addq next end-code F-79 CODE 2- 2 sp ) subq next end-code MVP code 2/ sp ) asr next end-code \ 2@ 2! gst851106 code 2@ \ addr -- d | get doublword even on byte boundary sp )+ os move \ read a byte at a time (slow but !!) 3 os bp di.l) sp -) byte move 2 os bp di.l) sp -) byte move 1 os bp di.l) sp -) byte move 0 os bp di.l) sp -) byte move word next end-code code 2! \ d addr -- | must be on word boundary !! sp )+ os move \ store a byte at a time too!! sp )+ 0 os bp di.l) byte move sp )+ 1 os bp di.l) byte move sp )+ 2 os bp di.l) byte move sp )+ 3 os bp di.l) byte move word next end-code \ 2DROP 2DUP 2OVER 2SWAP gst850927 F-79 CODE 2DROP 4 sp long addq word next end-code F-79 CODE 2DUP sp ) sp -) long move word next end-code F-79 CODE 2OVER 4 sp d) sp -) long move word next end-code F-79 CODE 2SWAP long sp )+ d0 move sp ) d1 move d0 sp ) move d1 sp -) move word next end-code \ 79-STANDARD : ; gst851001 F-79 : 79-STANDARD ; F-79 : : SP@ CSP ! CURRENT @ CONTEXT ! CREATE SMUDGE ] ;CODE ip d0 long move bp d0 long sub word \ cnvrt to forth addr d0 rp -) move 2 w bp di.l) ip lea next end-code F-79 : ; ?CSP COMPILE EXIT SMUDGE [COMPILE] [ ; IMMEDIATE \ < <# <+LOOP> gst851001F-79 CODE < sp )+ sp )+ cmpm d0 slt 1 d0 andi d0 sp -) move next end-code F-79 : <# PAD HLD ! ; MVP CODE <+LOOP> sp )+ d0 move < if d0 rp ) add rp ) d0 move 2 rp d) d0 cmp < if 4 rp long addq 2 ip addq word else ip ) a0 move a0 ip long adda word then else d0 rp ) add rp ) d0 move 2 rp d) d0 cmp < if ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then then next end-code \ <-FIND> <."> </LOOP> gst851106 MVP : <-FIND> Token CONTEXT @ @ <FIND> ; MVP : <."> ((")) Type ; \ show that string MVP CODE </LOOP> sp )+ d0 move d0 rp ) add rp ) d0 move 2 rp d) d0 cmp CARRY if \ not done ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then next end-code \ <;CODE> <<CMOVE> gst851001 MVP : <;CODE> R> LATEST PFA CFA ! ; MVP CODE <<CMOVE> d0 long clr word \ for later sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a1 lea \ a1=fm a0=to d0=# long d0 a0 adda d0 a1 adda word \ pt to end BEGIN 1 d0 subq 0>= WHILE a1 -) a0 -) byte move word REPEAT next end-code \ <ABORT"> <ABORT> gst850920 MVP : <ABORT"> IF WHERE CR R@ COUNT TYPE SP! QUIT ELSE R> DUP C@ + 1+ dup 1 and + >R THEN ; MVP : <ABORT> SP! ?STACK [COMPILE] FORTH DEFINITIONS QUIT ; ( <BLOCK> <CMOVE MVP-FORTH) MVP : <BLOCK> OFFSET @ + >R PREV @ DUP @ R@ - 2* IF BEGIN +BUF NOT IF DROP R@ BUFFER DUP R@ 1 R/W 2- THEN DUP @ R@ - 2* NOT UNTIL DUP PREV ! THEN R> DROP 2+ ; MVP : <CMOVE DUP 1 < IF 2DROP DROP ELSE <<CMOVE> THEN ; \ <CMOVE> <CR> <DO> gst851001 MVP CODE <CMOVE> sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a1 lea \ a1=fm a0=to d0=# BEGIN 1 d0 subq 0>= WHILE a1 )+ a0 )+ byte move word REPEAT next end-code MVP : <CR> acr emit alf emit 0 out ! ; MVP CODE <DO> sp )+ rp -) long move word next end-code \ <EXPECT> gst850902 MVP : <EXPECT> OVER + OVER DO KEY DUP BSIN = OVER ADEL = OR IF DROP DUP I = DUP R> 2- + >R IF BELL ELSE BSOUT DUP EMIT 20 EMIT THEN ELSE DUP 0D = IF LEAVE DROP BL 0 ELSE DUP THEN I C! 0 I 1+ ! THEN EMIT 1 /LOOP DROP ; \ <FILL> gst851001MVP CODE <FILL> sp )+ d1 move sp )+ d0 move sp )+ os move 0 os bp di.l) a1 lea BEGIN 1 d0 subq 0>= while d1 a1 )+ byte move word REPEAT next end-code MVP CODE <FIND> sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a2 lea d0 clr d1 clr d2 clr ( flag ) w clr ( traverse? ) BEGIN a2 a1 long move ( a1=crnt str a0=crnt nfa ) forth \ NOTICE !!! <find> is HUGE and overflows a block !!!!! \ <FIND> ... continued ... !!!!! gst851001assembler byte a1 )+ d0 move a0 )+ d1 move d1 os word move byte 1f # d0 and 3f # d1 and ( leave smudge bit ) word BEGIN d0 d1 cmp ( char =? ) 0= WHILE 1 w moveq byte a1 )+ d0 move a0 )+ d1 move word REPEAT 7f # d1 byte and word d0 d1 cmp 0<> IF w a0 long suba word ( -1 if after len byte ) BEGIN a0 )+ byte tst word 0< UNTIL THEN a0 d3 long move 1 d3 addq fe # d3 byte and d3 a0 long move word \ lfa is next word after nfa d0 d1 cmp ( was it found? ) 0= IF ( yes ) bp a0 long suba word 4 a0 addq a0 sp -) move ( pfa ) word os sp -) move ( len ) 1 d2 moveq ( flag ) os clr ( set zero to stop loop ) ELSE w clr a0 ) os move 0 os bp di.l) a0 lea THEN 0= UNTIL ( til end ) d2 sp -) move next end-code ( <INTERPRET> MVP-FORTH) MVP : <INTERPRET> BEGIN -FIND IF STATE @ < IF CFA , ELSE CFA EXECUTE THEN ELSE HERE NUMBER DPL @ 1+ IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN ?STACK AGAIN ; \ <LINE> <LOAD> gst850902 MVP : <LINE> BLOCK SWAP C/L * + C/L ; MVP : <LOAD> ?DUP NOT ABORT" Unloadable" BLK @ >R >IN @ >R 0 >IN ! BLK ! INTERPRET R> >IN ! R> BLK ! ; \ <LOOP> gst851001 MVP CODE <LOOP> 1 rp ) addq rp ) d0 move \ loop by one get index 2 rp d) d0 cmp < if \ not done ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then next end-code \ <NUMBER> <PAGE> gst850924 MVP : <NUMBER> 0 0 ROT DUP 1+ C@ AMINUS = DUP >R + -1 DPL ! CONVERT DUP C@ BL > IF DUP C@ ADOT = NOT ABORT" Not recognized" 0 DPL ! CONVERT DUP C@ BL > ABORT" Not recognized" THEN DROP R> IF DNEGATE THEN ; MVP : <PAGE> CR ; \ <R/W> gst851223 MVP : <R/W> \ addr blk f -- | f=0 write f=1 read block >r Blocks/File /mod \ addr blk file# -- | dup FileHandle 2@ 2dup or 0= Abort" File not open" 2swap filesize @ 1- over < abort" Block not within file" 400 u* 2over Offset_beginning Seek 2drop rot A>L 2swap 400 rot rot \ daddr len dfile -- r> if read else write then 400 swap - disk-error ! ; \ <VOCABULARY79> <VOCABULARYFIG> gst851223 MVP : <VOCABULARY79> CREATE 81 c, a0 c, ' FORTH , HERE VOC-LINK @ , VOC-LINK ! DOES> 2+ CONTEXT ! ; MVP : <VOCABULARYFIG> CREATE 81 c, a0 c, CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES> 2+ CONTEXT ! ; \ <WARM> <WORD> gst851223 MVP : <WARM> \ final part of COLD PAGE ." MVP-FORTH Version 1.00.03A Amiga" CR CR banner ABORT ; MVP : <WORD> 'STREAM SWAP ENCLOSE 2DUP > IF 2DROP 2DROP 0 HERE ! ELSE >IN +! OVER - DUP >R HERE C! + HERE 1+ R> DUP FF > ABORT" Input > 255" 1+ CMOVE THEN HERE ; \ = > >IN >R gst850902 F-79 : = - NOT ; F-79 : > SWAP < ; F-79 36 USER >IN F-79 CODE >R sp )+ rp -) move next end-code \ >UpperCase ? ?COMP gst851001 code >UpperCase \ addr count -- | converts chars to upper sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea here byte a0 ) os move ascii a os cmpi >= IF ascii z os cmpi <= IF 0df os andi THEN THEN os a0 )+ move d0 dbra next end-code F-79 : ? @ . ; MVP : ?COMP STATE @ NOT ABORT" Compile only" ; \ ?CSP ?DUP ?LOADING ?PAIRS gst851223 MVP : ?CSP SP@ CSP @ - ABORT" Definition not finished" ; F-79 : ?DUP DUP IF DUP THEN ; MVP : ?ENOUGH \ n -- | abort if not >= n items on stack DEPTH 1- > ABORT" Not enough items on stack" ; MVP : ?LOADING BLK @ NOT ABORT" Loading only" ; MVP : ?PAIRS - ABORT" Conditionals not paired" ; \ ?STACK ?STREAM ?TREMINAL @ gst851001 MVP : ?STACK SP@ S0 SWAP U< ABORT" Stack out of bounds" SP@ HERE 80 + U< ABORT" Stack full" ; MVP : ?STREAM ABORT" Input stream exhausted" ; MVP : ?TERMINAL '?TERMINAL @ EXECUTE ; F-79 CODE @ sp ) os move 0 os bp di.l) 0 sp d) byte move word 1 os bp di.l) 1 sp d) byte move word next end-code \ ABORT ABORT" ABS gst851106F-79 : ABORT 'ABORT @ EXECUTE ; MVP : ABORT" ?COMP COMPILE <ABORT"> 'STREAM C@ 22 = IF 1 >IN +! 0 C, ELSE 22 WORD DUP C@ 1+ SWAP OVER + C@ 22 = NOT ?STREAM ALLOT Aligned THEN ; IMMEDIATE F-79 : ABS DUP +- ; MVP : ALIGNED here 1 and if 0 c, then ; \ AGAIN ALLOT AND BASE gst850924 MVP : AGAIN 1 ?PAIRS COMPILE BRANCH HERE - , ; IMMEDIATE F-79 : ALLOT DP +! ; F-79 CODE AND sp )+ d0 move d0 sp ) and next end-code F-79 38 USER BASE ( BEGIN BL BLANK BLK BLOCK MVP-FORTH) F-79 : BEGIN ?COMP HERE 1 ; IMMEDIATE MVP 20 CONSTANT BL MVP : BLANK BL FILL ; F-79 3A USER BLK F-79 : BLOCK 'BLOCK @ EXECUTE ; \ BRANCH BUFFER gst851001 MVP CODE BRANCH ip ) a0 move a0 ip long adda word next end-code F-79 : BUFFER USE @ PREV @ = IF USE @ +BUF DROP USE ! THEN USE @ DUP >R BEGIN +BUF UNTIL USE ! R@ @ 0< IF R@ 2+ R@ @ 7FFF AND 0 R/W THEN R@ ! R@ PREV ! R> 2+ ; \ BYE C, C/L gst851223 MVP : BYE FREEZE CloseAll CloseAlt StdOut 2@ close \ close everything! WB? IF EXEC: FF7C ( forbid -- required !!! ) WBmsg 2@ >ra 1 EXEC: FE86 ( ReplyMsg ) THEN <bye> ; \ and finally return to caller rc=0 \ 0 >rd 1X DOS: FF70 ; \ and return code = 0 MVP : C, HERE C! 1 ALLOT ; MVP 40 CONSTANT C/L \ C! C@ CAPS gst851001 F-79 CODE C! sp )+ os move sp )+ d0 move d0 0 os bp di.l) byte move word next end-code F-79 CODE C@ sp )+ os move d0 clr 0 os bp di.l) d0 byte move word d0 sp -) move next end-code MVP variable CAPS 1 Caps ! \ 1=>uppercase \ CFA CHANGE CLEAR gst851001 MVP : CFA 2- ; MVP : CHANGE FREEZE LIMIT HDBT #BUFF * - DUP ' FIRST ! US - DUP RTS - DUP INIT-USER ! [ INIT-USER 4 + ] LITERAL ! DUP [ INIT-USER 2+ ] LITERAL ! UP OVER RPP ORIGIN HERE ! HERE ROT ROT ! ROT ROT ! EXECUTE ; MVP : CLEAR OFFSET @ + BUFFER 400 BL FILL UPDATE ; \ CMOVE COLD COMPILE gst851223 F-79 : CMOVE DUP 1 < IF 2DROP DROP ELSE <CMOVE> THEN ; MVP : COLD AmigaCold \ first special init code EMPTY-BUFFERS INIT-USER UP @ 6 + US 6 - CMOVE FIRST USE ! FIRST PREV ! File0 0 EPRINT ! INIT-FORTH @ ' FORTH 2+ ! DECIMAL Warm ; F-79 : COMPILE ?COMP R> DUP 2+ >R @ , ; \ CONFIGURE CONSTANT gst851001 \ MVP : \ CONFIGURE ?CONFIGURE \ CR ." Number of files? " KEY 31 - DUP 5 U< NOT \ ABORT" Too many files" DUP 31 + EMIT 1+ ' #files ! \ \ #files 0 \ \ DO CR ." File " I . ." ? " KEY 30 - DUP 7 U< NOT \ \ ABORT" OUT OF RANGE" DUP 30 + EMIT LOOP \ File0 CR CR ." FILE0 selected " CR ; F-79 : CONSTANT CREATE , ;CODE 2 w bp di.l) sp -) move next end-code ( CONTEXT CONVERT COUNT MVP-FORTH) F-79 3C USER CONTEXT F-79 : CONVERT BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ U* DROP ROT BASE @ U* D+ DPL @ 1+ IF 1 DPL +! THEN R> REPEAT R> ; F-79 : COUNT DUP 1+ SWAP C@ ; \ COUT CPOUT CR gst850902 F-79 : CR 'CR @ EXECUTE ; \ CREATE CSTAT gst851106 F-79 : CREATE here dup -FIND IF 1F and 0= abort" Attempted to redefine 'null'" drop warning @ IF DUP COUNT TYPE SPACE ." Isn't unique " THEN THEN C@ WIDTH @ MIN 1+ ALLOT DUP 80 TOGGLE HERE 1- 80 TOGGLE Aligned LATEST , 2 ALLOT CURRENT @ ! ;CODE 2 w addq w sp -) move next end-code \ CSP CURRENT D+ gst850927 MVP 3E USER CSP F-79 40 USER CURRENT F-79 CODE D+ sp )+ d0 long move d0 sp ) long add word next end-code \ D+- D. D.R gst851223 MVP : D+- 0< IF DNEGATE THEN ; MVP : D. 0 D.R SPACE ; MVP : D.R 3 ?enough \ DEPTH 3 < ABORT" Empty stack" >R SWAP OVER DUP D+- <# #S ROT SIGN #> R> OVER - SPACES TYPE ; \ D< DABS gst850927 F-79 : D< ROT 2DUP = IF ROT ROT DNEGATE D+ 0< ELSE SWAP < SWAP DROP THEN SWAP DROP ; MVP : DABS DUP D+- ; \ DECIMAL DEFINITIONS DEPTH gst850927 F-79 : DECIMAL 0A BASE ! ; F-79 : DEFINITIONS CONTEXT @ CURRENT ! ; F-79 : DEPTH SP@ S0 SWAP - 2/ ; \ DIGIT DISK-ERROR gst851106 MVP CODE DIGIT sp )+ d0 move sp ) d1 move 30 # d1 sub 0< IF here label DigitBad sp ) clr ELSE 0a d1 cmpi 0>= \ true if not decimal IF 11 d1 cmpi DigitBad bmi \ '9'-'A' bad 7 d1 subq THEN \ 'A'-'~' into 10 .. d0 d1 cmp DigitBad bpl \ error if over base d1 sp ) move 1 # sp -) move THEN next end-code MVP VARIABLE DISK-ERROR 0 DISK-ERROR ! \ DLITERAL DNEGATE DO gst851106 MVP : DLITERAL STATE @ IF SWAP [COMPILE] LITERAL [COMPILE] LITERAL THEN ; IMMEDIATE F-79 CODE DNEGATE sp ) long neg word next end-code F-79 : DO COMPILE <DO> HERE 3 ; IMMEDIATE \ DODOES DP DPL DPUSH gst850930 \ ACHTUNG!! dodoes must be w/in 1st 32K of dictionary !!!!!! ASSEMBLER HERE LABEL DODOES ip d0 long move bp d0 long sub rp )+ ip long move word d0 rp -) move 2 w addq w sp -) move next FORTH : (does>) \ so user code can generate the does call compile [ 4eab , ] compile [ dodoes , ] ; F-79 : DOES> ?CSP COMPILE <;CODE> \ set up so it later does ;code (does>) ; immediate \ lay down a jsr dodoes \ DP DPL DROP DUP gst850930 MVP 12 USER DP MVP 42 USER DPL F-79 CODE DROP 2 sp long addq word next end-code F-79 CODE DUP sp ) sp -) move next end-code ( ELSE EMIT EMPTY-BUFFERS MVP-FORTH) F-79 : ELSE 2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 [COMPILE] THEN 2 ; IMMEDIATE F-79 : EMIT 'EMIT @ EXECUTE ; F-79 : EMPTY-BUFFERS FIRST LIMIT OVER - 0 <FILL> #BUFF 0 DO 7FFF HDBT I * FIRST + ! LOOP ; \ ENCLOSE EPRINT gst851001MVP CODE ENCLOSE sp )+ d0 move ( char ) sp ) os move ( addr ) 0 os bp di.l) a0 lea -1 # d1 move ( n ) begin 1 d1 addq a0 )+ d2 byte move d2 d0 cmp word 0<> until d1 sp -) move ( n1 ) d2 byte tst word 0= if d1 d0 move 1 d1 addq ( 1st char=null ) else here label 1ENCL ( like BEGIN ) 1 d1 addq a0 )+ d2 byte move d2 d0 cmp word 0= if d1 d0 move 1 d0 addq ( found terminator ) else d2 byte tst 1ENCL bne ( no term, not null ) word d1 d0 move ( found null before terminator ) then then d1 sp -) move d0 sp -) move ( n2 n3 ) next end-code \ EPRINT EXECUTE EXIT gst851001 MVP VARIABLE EPRINT 0 EPRINT ! F-79 CODE EXECUTE sp )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp end-code F-79 CODE EXIT rp )+ os move 0 os bp di.l) ip lea ip )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp end-code \ EXPECT FENCE gst850924 F-79 : EXPECT 'EXPECT @ EXECUTE ; MVP 10 USER FENCE \ FILL FIND FIRST FLD gst850924 F-79 : FILL OVER 0> IF <FILL> ELSE 2DROP DROP THEN ; F-79 : FIND -FIND IF DROP CFA ELSE 0 THEN ; MVP BUF1 CONSTANT FIRST MVP 44 USER FLD \ FORGET gst850927 F-79 : FORGET Token CURRENT @ @ <FIND> 0= ABORT" Not in CURRENT vocabulary" DROP NFA DUP FENCE @ U< ABORT" In protected dictionary" >R R@ CONTEXT @ U< IF [COMPILE] FORTH THEN R@ CURRENT @ U< IF [COMPILE] FORTH DEFINITIONS THEN VOC-LINK @ BEGIN R@ OVER U< WHILE @ REPEAT DUP VOC-LINK ! BEGIN DUP 4 - BEGIN PFA LFA @ DUP R@ U< UNTIL OVER 2- ! @ ?DUP 0= UNTIL R> DP ! ; \ FORTH FREEZE HERE gst850902 F-79 VOCABULARY FORTH IMMEDIATE MVP : FREEZE UP @ 6 + INIT-USER 30 CMOVE ' FORTH 2+ @ INIT-FORTH ! ; F-79 : HERE DP @ ; ( HEX HLD HOLD HPUSH MVP-FORTH) MVP : HEX 10 BASE ! ; MVP 46 USER HLD F-79 : HOLD -1 HLD +! HLD @ C! ; \ I I' IF IMMEDIATE gst850902 F-79 CODE I rp ) sp -) move next end-code MVP CODE I' 2 rp d) sp -) move next end-code F-79 : IF COMPILE 0BRANCH HERE 0 , 2 ; IMMEDIATE F-79 : IMMEDIATE LATEST 40 TOGGLE ; \ INIT-FORTH INIT-USER IOS INTERPRET gst850902 MVP INIT-FORTH CONSTANT INIT-FORTH MVP INIT-USER CONSTANT INIT-USER MVP : INTERPRET 'INTERPRET @ EXECUTE ; \ J KEY LATEST LEAVE gst850902 F-79 CODE J 4 rp d) sp -) move next end-code F-79 : KEY 'KEY @ EXECUTE ; MVP : LATEST CURRENT @ @ ; F-79 CODE LEAVE rp ) d0 move d0 2 rp d) move next end-code ( LFA LIMIT LIST MVP-FORTH) MVP : LFA 4 - ; MVP EM CONSTANT LIMIT F-79 : LIST CR DUP SCR ! ." SCR #" U. 10 0 DO CR R@ 3 .R SPACE R@ SCR @ .LINE ?TERMINAL IF LEAVE THEN LOOP CR ; \ LIT LITERAL LOAD LOOP gst850902 MVP CODE LIT ip )+ sp -) move next end-code F-79 : LITERAL STATE @ IF COMPILE LIT , THEN ; IMMEDIATE F-79 : LOAD 'LOAD @ EXECUTE ; F-79 : LOOP 3 ?PAIRS COMPILE <LOOP> HERE - , ; IMMEDIATE \ M* M*/ M+ M/ gst850924 MVP : M* 2DUP XOR >R ABS SWAP ABS U* R> D+- ; MVP : M*/ 2DUP XOR SWAP ABS >R SWAP ABS >R OVER XOR ROT ROT DABS SWAP R@ U* ROT R> U* ROT 0 D+ R@ U/MOD ROT ROT R> U/MOD SWAP DROP SWAP ROT D+- ; MVP : M+ S->D D+ ; MVP : M/ OVER >R >R DUP D+- R@ ABS U/MOD R> R@ XOR +- SWAP R> +- SWAP ; \ M/MOD MAX MIN MOD gst850924 MVP : M/MOD >R 0 R@ U/MOD R> SWAP >R U/MOD R> ; F-79 : MAX 2DUP < IF SWAP THEN DROP ; F-79 : MIN 2DUP > IF SWAP THEN DROP ; F-79 : MOD /MOD DROP ; \ MOVE MPYX NEGATE gst850902 F-79 : MOVE 0 MAX 2* <CMOVE> ; F-79 CODE NEGATE sp ) d0 move d0 neg d0 sp ) move next end-code \ NFA NOT gst850920 MVP : NFA 5 - -1 TRAVERSE ; F-79 CODE NOT sp ) tst d0 seq 1 d0 andi d0 sp ) move next end-code \ NUMBER OFFSET OR OUT gst850902 MVP : NUMBER 'NUMBER @ EXECUTE ; MVP 48 USER OFFSET F-79 CODE OR sp )+ d0 move d0 sp ) or next end-code MVP 4A USER OUT \ OVER P! P@ PAD gst850902 F-79 CODE OVER 2 sp d) sp -) move next end-code F-79 : PAD HERE 44 + ; \ PAGE PCR PFA PICK gst850924 MVP : PAGE 'PAGE @ EXECUTE ; MVP : PFA 1 TRAVERSE 6 + -2 and ( to word aligned ) ; F-79 : PICK DUP 1 < ABORT" PICK argument < 1" 2* SP@ + @ ; \ PKEY POUT PP gst850924 MVP : PP DUP FFF0 AND ABORT" Off screen" 1 TEXT PAD 1+ SWAP SCR @ <LINE> CMOVE UPDATE ; \ PQTER PREV QUERY gst850902 MVP VARIABLE PREV FIRST PREV ! F-79 : QUERY TIB @ 50 EXPECT 0 >IN ! ; \ QUIT R# R/W gst850924 F-79 : QUIT 0 BLK ! [COMPILE] [ BEGIN CR RP! QUERY INTERPRET STATE @ NOT IF ." ok" THEN AGAIN ; MVP 4C USER R# MVP : R/W 'R/W @ EXECUTE ; \ R> R@ REPEAT gst850902 F-79 CODE R> rp )+ sp -) move next end-code F-79 CODE R@ rp ) sp -) move next end-code F-79 : REPEAT >R >R [COMPILE] AGAIN R> R> 2- [COMPILE] THEN ; IMMEDIATE \ ROLL ROT RP! gst851001 F-79 : ROLL DUP 1 < ABORT" ROLL argument < 1" 1+ DUP PICK SWAP 2* SP@ + BEGIN DUP 2- @ OVER ! 2- SP@ OVER U< NOT UNTIL 2DROP ; F-79 CODE ROT sp )+ d0 long move word sp )+ d1 move d0 sp -) long move word d1 sp -) move next end-code MVP CODE RP! IncomingSP bp d) rp long move word \ save original REAL sp 20 rp long subq word ( leave some room ) next end-code \ S->D S0 gst851106 MVP CODE S->D sp )+ d0 move d0 long ext d0 sp -) long move word next end-code MVP : S0 SP0 @ ; \ SAVE-BUFFERS SCR gst850924 F-79 : SAVE-BUFFERS #BUFF 1+ 0 DO 7FFF BUFFER DROP LOOP ; F-79 4E USER SCR \ SIGN SMUDGE SP! SP0 gst851001 F-79 : SIGN 0< IF 2D HOLD THEN ; MVP : SMUDGE LATEST 20 TOGGLE ; MVP CODE SP! up bp d) w move 6 w bp di.l) os move \ get sp value 0 os bp di.l) sp lea ( absolute now ) next end-code MVP 06 USER SP0 \ SP@ SPACE SPACES gst850924 MVP CODE SP@ sp d0 long move bp d0 sub d0 sp -) word move next end-code F-79 : SPACE BL EMIT ; F-79 : SPACES 0 MAX ?DUP IF 0 DO SPACE LOOP THEN ; \ STATE SWAP gst850924 F-79 50 USER STATE F-79 CODE SWAP sp ) long d0 move d0 swap d0 long sp ) move word next end-code \ TEXT THEN TIB gst850927 MVP : TEXT HERE C/L 1+ BLANK WORD BL OVER DUP C@ + 1+ C! PAD C/L 1+ CMOVE ; F-79 : THEN ?COMP 2 ?PAIRS HERE OVER - SWAP ! ; IMMEDIATE MVP 0A USER TIB MVP : TOKEN \ -- addr | get next token from input stream BL WORD Caps @ IF dup count >uppercase THEN ; \ TOGGLE TRAVERSE gst850924 MVP CODE TOGGLE sp )+ d0 move sp )+ os move d0 0 os bp di.l) byte eor word next end-code MVP : TRAVERSE SWAP dup c@ 07f < if over + then \ 1st must be 80h BEGIN OVER + 07F OVER C@ < UNTIL SWAP DROP ; \ TYPE U* U. gst850927 F-79 : TYPE 'TYPE @ EXECUTE ; \ TYPE DUP 0> \ IF OVER + SWAP \ DO I C@ EMIT 1 /LOOP \ ELSE 2DROP THEN ; F-79 CODE U* sp )+ d0 move sp )+ d0 mulu d0 sp -) long move word next end-code F-79 : U. 0 D. ; \ U/MOD gst850924 F-79 CODE U/MOD sp )+ d0 move 0<> if sp )+ d1 long move word d0 d1 divu d1 swap d1 sp -) long move word then next end-code ( U< UNTIL UP UPDATE USE MVP-FORTH) F-79 : U< 0 SWAP 0 D< ; F-79 : UNTIL 1 ?PAIRS COMPILE 0BRANCH HERE - , ; IMMEDIATE MVP UP CONSTANT UP F-79 : UPDATE PREV @ @ 8000 OR PREV @ ! ; MVP VARIABLE USE FIRST USE ! \ USER VARIABLE VOC-LINK VOCABULARY gst851001 MVP : USER CONSTANT ;CODE 2 w bp di.l) d0 move up bp d) d0 add \ d0=(w)+bp d0 sp -) move next end-code F-79 : VARIABLE CREATE 2 ALLOT ; MVP 14 USER VOC-LINK F-79 : VOCABULARY 'VOCABULARY @ EXECUTE ; \ WARM WARNING WHERE gst851223 MVP : WARM 'warm @ execute ; \ finish up COLD MVP 0E USER WARNING MVP : WHERE BLK @ IF BLK @ DUP SCR ! CR CR ." SCR# " DUP . >IN @ 3FF MIN C/L /MOD DUP ." LINE# " . C/L * ROT BLOCK + CR CR C/L -TRAILING TYPE >IN @ 3FF > + ELSE >IN @ THEN CR HERE C@ DUP >R - HERE R@ + 1+ C@ 20 = IF 1- THEN SPACES R> 0 DO 5E EMIT LOOP ; ( WHILE WIDTH WORD X MVP-FORTH) F-79 : WHILE [COMPILE] IF 2+ ; IMMEDIATE MVP 0C USER WIDTH F-79 : WORD 'WORD @ EXECUTE ; F-79 : X BLK @ IF STATE @ ?STREAM THEN R> DROP ; IMMEDIATE IS-X \ XOR [ [COMPILE] ] gst850924 F-79 CODE XOR sp )+ d0 move d0 sp ) eor next end-code F-79 : [ 0 STATE ! ; IMMEDIATE F-79 : [COMPILE] ?COMP -FIND NOT ABORT" Not found" DROP CFA , ; IMMEDIATE F-79 : ] C0 STATE ! ;
